#!/usr/bin/env perl
#$Id: watchmen 103 2014-11-12 21:54:47Z proler $ $URL: http://watchmen.googlecode.com/svn/trunk/watchmen $ Oleg Alexeenkov <proler@gmail.com>
# perltidy -b -i=2 -ce -l=128 -nbbc -sob -otr -sot *.pm *.pl *.pl.dist *.cgi *.t *.PL watchmen
package App::watchmen;
use strict;

sub get_params_one(@) {    # WELCOME TO PERL %-)
  local %_ = %{ ref $_[0] eq 'HASH' ? shift : {} };
  for (@_) {
    tr/+/ /, s/%([a-f\d]{2})/pack'C',hex$1/gei for ( $a, $b ) = /^([^=]+=?)=(.+)$/ ? ( $1, $2 ) : ( /^([^=]*)=?$/, /^-/ );
    $_{$a} = $b;
  }
  wantarray ? %_ : \%_;
}

=head1 NAME

 watchmen - watch daemons and restart

=head1 SYNOPSIS

 watchmen [--configkey=configvalue] [-svcname__svckey=svcvalue] [command[=param]] ...
 where command:
 check[=svc] stop[=svc] restart[=svc] keep[=svc] list avail help
 where svc can be name of service or name of group. if group - all services in this group will be affected

=head1 AVAILABILITY

The latest version of B<watchmen> is available from
http://code.google.com/p/watchmen/

=head1 REQUIREMENTS

to use all features , install the following:

 * DBI and DBD::mysql or DBD::Pg or DBD::PgPP
 * LWP::UserAgent and URI::URL
 * Email::Send for mail reports

  sudo portinstall databases/p5-DBD-mysql databases/p5-DBD-Pg www/p5-libwww mail/p5-Email-Send

=head1 DESCRIPTION

B<watchmen> check availability of your services and [re]start them if any problems detected.

 * process in ps 
 * tcp or udp socket
 * correct http answer
 * database query execution
 * memory and processes in limit, and reaching maximum of any (numeric) ps columns:  SL  RE PAGEIN   VSZ   RSS   LIM TSIZ %CPU %MEM
 * any custom check 

=head1 EXAMPLES

 #check and restart default services
 watchmen

 #list of enabled services
 watchmen list

 #list of available services
 watchmen avail

 #list of available groups
 watchmen group

 #full log
 watchmen --log_all

 #reatart apache if more than 5 httpd proc, dont check sshd, load custom config
 watchmen -apache__max_proc=5 -sshd__enable=0 --config=/path/to/my/config

 #check only 2 services with log
 watchmen check=named check=mysql --log_all 

 #stop all EXCEPT sshd
 watchmen stop

 #stop all services with bluetooth group 
 watchmen stop=bluetooth

 #stop all services in /etc/rc.d
 watchmen stop=system

 #stop all services in /usr/local/etc/rc.d
 watchmen stop=local

 #check services every 5 seconds without exit
 watchmen keep --sleep=5

 #same, only for mysqld
 watchmen keep=mysqld --sleep=5


=head1 INSTALL

 recommended libs: LWP, URI
 freebsd: cd /usr/ports/www/p5-libwww && make install clean
 or 
 perl -MCPAN -e "install LWP, URI"


 cp watchmen /usr/local/bin/ ; cp watchmen.conf.dist /usr/local/etc/watchmen.conf
 edit /usr/local/etc/watchmen.conf

 run watchmen twice. second run must be quiet (all ok) if not - edit config

 add to crontab:
 echo "*       *       *       *       *       root    /usr/local/bin/watchmen" >> /etc/crontab
 or line via root's  crontab -e
 *    *       *       *       *       /usr/local/bin/watchmen

=head1 CONFIGURE

 by default some of default services enabled

 read [and edit] watchmen.conf

 you can configure services from /etc/rc.conf[.local] file[s]:
 for config string  $svc{service}{key} = 'value'; write to rc.conf:
 service_key="value"
 example:
 apache22_http="81" 
 #or define new service, with one of correct keys: process tcp udp http https :
 nginx_enable="YES"
 nginx_process="nginx"
 nginx_http="8001"
 nginx_http_check="<html"
 nginx_group="web"

=head1 TODO

 self pid & check
 /tmp/socketfile check
 various handlers
 rsync --daemon
 more default ports [tested!]
 ?.pid usage?
 identify by process desc (sendmail)
 keep: step by step skip fail checks (http->tcp->proc)
 group once for samba

=head1 COPYRIGHT

watchmen
Copyright (C) 2008-2010 Oleg Alexeenkov proler@gmail.com

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.

=cut

our $VERSION = '0.08';    # . '.' . ( split( ' ', '$Revision: 103 $' ) )[1];
use IO::Socket;
use Time::HiRes qw(time sleep);
use POSIX qw(strftime);
use Cwd;
use Data::Dumper;
$Data::Dumper::Sortkeys = $Data::Dumper::Useqq = $Data::Dumper::Indent = $Data::Dumper::Terse = 1;
our ( %config, %svc, %stat );
our $root_path;

BEGIN {
  ( $ENV{'SCRIPT_FILENAME'} || $0 ) =~ m|^(.+)[/\\].+?$|;    #v0w
  ( $root_path = ( $1 and $1 ne '.' ? $1 : getcwd ) . '/' ) =~ tr|\\|/|;
}

sub get_params(;$$) {                                        #v7
  my ( $string, $delim ) = @_;
  $delim ||= '&';
  read( STDIN, local $_ = '', $ENV{'CONTENT_LENGTH'} ) if !$string and $ENV{'CONTENT_LENGTH'};
  local %_ =
    $string
    ? get_params_one split $delim, $string
    : (
    get_params_one(@ARGV), map { get_params_one split $delim, $_ } split( /;\s*/, $ENV{'HTTP_COOKIE'} ),
    $ENV{'QUERY_STRING'}, $_
    );
  wantarray ? %_ : \%_;
}
{
  my %fh;
  my $savetime;

  sub file_append(;$@) {
    local $_ = shift;
    for ( defined $_ ? $_ : keys %fh ) { close( $fh{$_} ), delete( $fh{$_} ) if $fh{$_} and !@_; }
    return if !@_;
    unless ( $fh{$_} ) { return unless open( $fh{$_}, '>>', $_ ); }
    print { $fh{$_} } @_;
    if ( time() > $savetime + 5 ) {
      close( $fh{$_} ), delete( $fh{$_} ) for keys %fh;
      $savetime = time();
    }
    return @_;
  }

  sub file_rewrite(;$@) {
    unlink $_[0] if $_[0];
    return &file_append;
  }
  END { close( $fh{$_} ) for keys %fh; }
}

sub file_read ($) {
  open my $f, '<', $_[0] or return;
  local $/ = undef;
  my $ret = <$f>;
  close $f;
  return $ret;
}
my ( %logs, $logto );

sub printlog (@) {    #v5
  push @{ $logs{$logto} ||= [] }, [@_] if $logto;
  return if defined $config{ 'log_' . $_[0] } and !$config{ 'log_' . $_[0] } and !$config{'log_all'};
  my $file = ( (
      defined $config{'log_all'}
      ? $config{'log_all'}
      : ( defined $config{ 'log_' . $_[0] } ? $config{ 'log_' . $_[0] } : $config{'log_default'} )
    )
  );
  my $noscreen;
  for ( 0 .. 1 ) {
    $noscreen = 1 if $file =~ s/^[\-_]// or !$file;
    $noscreen = 0 if $file =~ s/^[+\#]//;
    $file = $config{'log_default'}, next if $file eq '1';
    last;
  }
  $file = undef if $file eq '1';
  my $html = !$file and ( $ENV{'SERVER_PORT'} or $config{'view'} eq 'html' or $config{'view'} =~ /http/i );
  my $xml = $config{'view'} eq 'xml';
  my @string = (
    ( $xml  ? '<debug><![CDATA['    : () ),
    ( $html ? '<div class="debug">' : () ),
    (
      ( ( $html || $xml ) and !$file ) ? ()
      : (
        human( 'date_time', ), ( $config{'log_micro'} ? human('micro_time') : () ), ( $config{'log_pid'} ? (" [$$]") : () ),
      )
    ), (
      $config{'log_caller'}
      ? (
        ' [', join( ',', grep { $_ and !/^ps/ } ( map { ( caller($_) )[ 2 .. 3 ] } ( 0 .. $config{'log_caller'} - 1 ) ) ), ']'
        )
      : ()
    ),
    ' ',
    join( ' ', @_ ),
    (),
    ( $html ? '</div>'      : () ),
    ( $xml  ? ']]></debug>' : () ),
    ("\n")
  );
  file_append( $config{'log_dir'} . $file, @string );
  print @string if @_ and $config{'log_screen'} and !$noscreen;
  flush() if $config{'log_flush'};
  return @_;
}

sub human($;@) {
  my $via = shift;
  return $config{'human'}{$via}->(@_) if ref $config{'human'}{$via} eq 'CODE';
  return @_;
}

sub alarmed {
  my ( $timeout, $proc, @proc_param ) = @_;
  my @ret;
  eval {
    local $SIG{ALRM} =
      sub { die "alarm\n" }
      if $timeout;    # NB: \n required
    alarm $timeout if $timeout;
    @ret = $proc->(@proc_param) if ref $proc eq 'CODE';
    alarm 0 if $timeout;
  };
  if ( $timeout and $@ ) {
    printlog( 'err', 'Sorry, unknown error (',
      $@, ') runs:', ' [', join( ',', grep $_, map ( ( caller($_) )[2], ( 0 .. 15 ) ) ), ']' ),
      unless $@ eq "alarm\n";    # propagate unexpected errors
    printlog( 'err', 'Sorry, timeout (', $timeout, ')' );
    return undef;
  } else {
    #printlog('info', 'alarmed else');
  }
  return wantarray ? @ret : $ret[0];
}
{    #Id: psmisc.pm 4412 2010-03-15 00:13:51Z pro  URL: svn://svn.setun.net/search/trunk/lib/psmisc.pm $
  my (@locks);

  sub lockfile($) {
    return ( $config{'lock_dir'} || './' ) . ( length $_[0] ? $_[0] : 'lock' ) . ( $config{'lock_ext'} || '.lock' );
  }

  sub lock (;$@) {
    my $name = shift;
    my %p = ref $_[0] eq 'HASH' ? %{ $_[0] } : @_;
    $p{'sleep'}   //= $config{'lock_sleep'}   // 1;
    $p{'timeout'} //= $config{'lock_timeout'} // 600 unless length $p{'timeout'};
    $p{'old'}     //= $config{'lock_old'}     // 3600;
    #$p{'readonly'} ||= 0; #dont write lock file, only wait
    my $waitstart = time();
    my $waits;
  LOCKWAIT:
    while ( -e lockfile $name) {
      printlog( 'lock', $name, 'ignore too old', -M lockfile $name, time() - $^T + 86400 * -M lockfile $name), last
        if time() - $^T + 86400 * -M lockfile $name > $p{'old'};
      printlog( 'lock', $name, 'fail, timeout', int( time() - $waitstart ) ), return 0 if time() - $waitstart > $p{'timeout'};
      printlog( 'lock', 'locked, wait', $name ) unless $waits++;
      sleep $p{'sleep'};
    }
    printlog( 'lock', 'wait ok, unlocked', $name, 'per', int( time() - $waitstart ) ) if $waits;
    return 1 if $p{'readonly'};
    local $_ = "pid=$$ time=" . int( time() );
    file_rewrite lockfile $name, $_;
    file_rewrite;    #flush
    if ( open my $f, '<', lockfile $name) {
      local $/ = undef;
      my $c = <$f>;
      close $f;
      printlog( 'warn', 'not my lock', $_, $c ), goto LOCKWAIT if $_ ne $c;
    } else {
      printlog( 'err', 'lock open err', $name, lockfile $name);
      return 0;
    }
    push @locks, lockfile $name;
    printlog 'lock', 'locked', lockfile $name;
    return 1;
  }

  sub unlock (;$) {
    my $name = shift;
    local $_ = pop @locks;
    push @locks, $_ if length $name and lockfile($name) ne $_;
    printlog 'lock', 'unlocking', $name, $name ? lockfile $name : $_;
    unlink $name ? lockfile($name) : $_;
  }

  sub unlock_all () {
    unlink $_ while $_ = pop @locks;
  }

  END {
    #printlog( 'lock', 'END locked unlock', @locks ) if @locks;
    unlock_all();
  }
}
our ( %prog, %ps );

sub prog_run($;@) {
  my $prog = shift;
  #printlog 'run', $prog, @_;
  $prog{$prog}{func}->(@_) if ref $prog{$prog}{func} eq 'CODE';
}

sub action ($$;@) {
  my ( $s, $action ) = ( shift, shift );
  return unless $action;
  printlog( 'warn', "no action [$action] for service [$s]" ) unless defined $svc{$s}{$action};
  return unless $svc{$s}{$action};
  return unless lock "$s.$action";
  ++$stat{action}{$s}{$action};
  my @ret;
  printlog(
    'action', $s, $action, '[',
    $svc{$s}{$action},
    ']',
    #"timeout:", config( $s, 'action_timeout_'.$action ) || config( $s, 'action_timeout' ) ); printlog('action',
    @ret = alarmed(
      config( $s, 'action_timeout_' . $action ) || config( $s, 'action_timeout' ),
      sub {
        my @ret;
        my $code =
            ref $svc{$s}{$action}             eq 'CODE' ? $svc{$s}{$action}
          : ref $svc{$s}{ $svc{$s}{$action} } eq 'CODE' ? $svc{$s}{ $svc{$s}{$action} }
          :                                               ();
        @ret = $code ? $code->( $s, $action, @_ ) : `$svc{$s}{$action}`;
        #
        return wantarray ? @ret : $ret[0];
      }
    )
  );
  unlock;
  return wantarray ? @ret : $ret[0];
}
%config = (
  rcorder => 'rcorder',
  service => 'service',
  rcd =>    #[qw(/etc/rc.d/ /usr/local/etc/rc.d/)],
    { '/etc/rc.d/' => { group => 'system' }, '/usr/local/etc/rc.d/' => { group => 'local' }, },
  rcdext => [ '', '.sh' ],
  ps => $^O eq 'freebsd' ? 'ps vxaww' : 'ps xaww',
# ps => 'ps a -o%cpu,%mem,acflag,args,%cpu,%mem,acflag,args,comm,command,cpu,etime,flags,inblk,jid,jobc,ktrace,label,lim,lockname,logname,lstart,majflt,minflt,msgrcv,msgsnd,mwchan,nice,nivcsw,nsigs,nswap,nvcsw,nwchan,oublk,paddr,pagein,pgid,pid,poip,ppid,pri,re,rgid,rgroup,rlink,rss,rtprio,ruid,ruser,sid,sig,sigcatch,sigignore,sigmask,sl,start,state,svgid,svuid,tdaddr,tdev,time,tpgid,tsid,tsiz,tt,tty,uprocp,ucomm,uid,upr,user,vsz,wchan,xstat',
  rcconf => [qw(/etc/defaults/rc.conf /etc/rc.conf /etc/rc.conf.local)],
  #log_screen=>1,
  action_timeout => 30,
  sleep          => 10,
  default        => {
    min_proc                => 1,
    max_proc                => 1000,
    sleep                   => 1,
    host                    => '127.0.0.1',    # for tcp, udp
    timeout                 => 3,              # for tcp, udp
    chain_noaction          => 10,             # keep: stop restarting after X fails
    chain_try_every         => 100,            # keep: but try to restart every Y cycles
    restart_hard_stop_sleep => 5,
    restart_hard_kill_sleep => 5,
    stop_hard               => sub {
      my ($s) = @_;
      return unless process_check($s);
      if ( lock "$s.stop_hard.stop" ) {
        printlog 'warn', $s, 'stop', system "daemon $svc{$s}{stop}";
        sleep $svc{$s}{restart_hard_stop_sleep};
      }
      my $pid;
      $pid = file_read( $svc{$s}{pidfile} ), $pid =~ s/\D//g, if $svc{$s}{pidfile};
      $svc{$s}{pid} ||= $pid;
      my $kill = $svc{$s}{pid} ? 'kill ' : 'killall ';
      my $flags;
      my $what = $svc{$s}{pid} ? $svc{$s}{pid} : $svc{$s}{process};
      prog_run 'ps';
      return unless process_check($s);
      printlog 'warn', $s, 'kill', $svc{$s}{process}, "$kill$flags$what",
        `$kill$flags$what`;    #$svc{$s}{pid} ? `kill $svc{$s}{pid}` : `killall $svc{$s}{process}`;
      sleep $svc{$s}{restart_hard_kill_sleep};
      prog_run 'ps';
      return unless process_check($s);
      $flags = '-9 ';
      printlog 'warn', $s, 'kill-9', $svc{$s}{process}, "$kill$flags$what", `$kill$flags$what`;
      return unless process_check($s);
      return 'cant kill';
    },
    stop_pid => sub {
      my ($s) = @_;
      #printlog 'dev', 'stoppid', Dumper $svc{$s};
      #return unless process_check($s);
      my $kill = 'kill ';
      for my $pid ( keys %{ $svc{$s}{action_pid} || {} } ) {
        my $flags;
        my $what = $pid;
        printlog 'warn', $s, 'kill', $svc{$s}{process}, "$kill$flags$what", `$kill$flags$what`;
        sleep $svc{$s}{restart_hard_kill_sleep};
        $flags = '-9 ';
        printlog 'warn', $s, 'kill', $svc{$s}{process}, "$kill$flags$what", `$kill$flags$what`;
      }
    },
  },
  restart_hard => sub {
    my ($s) = @_;
    my @ret;
    printlog( 'warn', $s, 'hard restart fail', @ret ), return @ret if @ret = action $s, 'stop_hard', $s;
    sleep 1;
    return action $s, 'start';
  },
  #log_all=>'+',
  log_default => '+' . ( $root_path =~ /watch/i ? $root_path : -d '/var/log/' ? '/var/log/' : $root_path ) . 'watchmen.log',
  log_screen  => 1,
  log_pid     => 1,
  log_check   => 0,
  log_rc      => 0,
  log_rcorder => 0,
  log_service => 0,
  log_enable  => 0,
  log_alive   => 0,
  log_info    => 0,
  log_ps      => 0,
  log_dbg     => 0,
  log_dmp     => 0,
  log_port    => 0,
  log_http    => 0,
  log_dbi     => 0,
  log_lock    => 0,
  lock_dir => ( $root_path =~ /watch/i ? $root_path : -d '/tmp/' ? '/tmp/' : $root_path ),    #==farcolorer
  http_code => qr/^[1-4]\d\d$/,
  human     => {
    date => sub {                                                                             #v1
      my $d = $_[1] || '/';
      return strftime "%Y${d}%m${d}%d", localtime( $_[0] || time() );
    },
    'time' => sub {
      my $d = $_[1] || ':';
      return strftime "%H${d}%M${d}%S", localtime( $_[0] || time() );
    },
    date_time => sub {
      return human( 'date', $_[0] || time(), $_[2] ) . ( $_[1] || '-' ) . human( 'time', $_[0] || time(), $_[3] );
    },
    float => sub {                                                                            #v1
      return ( $_[0] < 8 and $_[0] - int( $_[0] ) )
        ? sprintf( '%.' . ( $_[0] < 1 ? 3 : $_[0] < 3 ? 2 : 1 ) . 'f', $_[0] )
        : int( $_[0] );
    },
    micro_time => sub {
      my $now = time();
      ( $now = human( 'float', abs( int($now) - $now ) ) ) =~ s/^0//;
      return ( $now or '' );
    },
    time_period => sub {                                                                      #v0
      my ( $tim, $delim, $sign ) = @_;
      $sign = '-', $tim = -$tim if $tim < 0;
      return '' if $tim == 0 or $tim > 1000000000;
      return ( $sign . human( 'float', $tim ) . $delim . "s" ) if $tim < 60;
      $tim = $tim / 60;
      return ( $sign . int($tim) . $delim . "m" ) if $tim < 60;
      $tim = $tim / 60;
      return ( $sign . int($tim) . $delim . "h" ) if $tim < 24;
      $tim = $tim / 24;
      return ( $sign . int($tim) . $delim . "d" ) if $tim <= 31;
      $tim = $tim / 30.5;
      return ( $sign . int($tim) . $delim . "M" ) if $tim < 12;
      $tim = $tim / 12;
      return ( $sign . int($tim) . $delim . "Y" );
      }
  },
  dbi_params => {
    mysql => [
      qw(host port database mysql_client_found_rows mysql_compression mysql_connect_timeout mysql_read_default_file mysql_read_default_group mysql_socket
        mysql_ssl mysql_ssl_client_key mysql_ssl_client_cert mysql_ssl_ca_file mysql_ssl_ca_path mysql_ssl_cipher
        mysql_local_infile mysql_embedded_options mysql_embedded_groups)
    ],
    Pg   => [qw(host port options tty dbname user password)],
    PgPP => [qw(dbname host port path debug)],
  },
  mail_from    => 'root@localhost',
  lock_timeout => 0,
  lock_old     => 600,
);
for ( ( $root_path =~ /watch/i ? "${root_path}watchmen.conf" : () ), "/usr/local/etc/watchmen.conf", "/etc/watchmen.conf", ) {
  $config{config} ||= $_, last if -r;
}
{
  my $order = 100000;
  sub n(@) { return { order => $order -= 10, @_ }; }
}
%svc = (
  sshd      => n( tcp => 22, no_stop => 1 ),
  openssh   => n( process => 'sshd', no_stop => 1 ),
  watchdogd => n,
  devd => n( no_stop => 1, ),
  #moused  => n( no_stop => 1, ), #started and stopped by devd
  syslogd => n,
  cron    => n,
  amd     => n,
  lpd     => n,
  powerd  => n,
  inetd   => n,
  named   => n( udp => 53, tcp => 53 ),
  dhcpd   => n( rcdname => 'isc-dhcpd', udp => 67 ),
  rtadvd  => n,
  ntpd    => n,
  rpcbind => n,
  #nfsd      => n( rcdname => 'nfs_server', ),
  nfs_server => n( process => 'nfsd', rcdname => 'nfsd', ),
  snmpd      => n,
  snmptrapd  => n,
  bsnmpd     => n,
  arpwatch   => n,
  smartd     => n,
  #sendmail_submit       => n( process    => 'sendmail', rcdname => 'sendmail', tcp => 25 ),
  sendmail_clientmqueue => n( process    => 'sendmail', rcdname => 'sendmail' ),
  mpd                   => n( rcconfname => 'mpd' ),
  mpd4                  => n( rcconfname => 'mpd' ),
  mpd5                  => n( rcconfname => 'mpd' ),
  openvpn               => n,
  apache                => n( process    => 'httpd',    http    => 80 ),
  apache2               => n( process    => 'httpd',    http    => 80 ),
  apache22              => n( process    => 'httpd',    http    => 80 ),           #tcp=>80 #https=>443
  apache24              => n( process    => 'httpd',    http    => 80 ),           #tcp=>80 #https=>443
  nginx     => n( http    => 80 ),
  fcgiwrap  => n,
  memcached => n,
  redis     => n( process => 'redis-server', ),
  rsyncd       => n( process => 'rsync',        tcp     => 873 ),
  postgresql   => n( process => 'postgres',     tcp     => 5432 ),
  mysql        => n( process => 'mysqld',       rcdname => 'mysql-server', tcp => 3306, ),   # restart => $config{restart_hard},
  sphinxsearch => n( process => 'searchd',      tcp     => 9312 ),                           #9306  , action_timeout_stop=>5
  svnserve     => n( process => 'svnserve.bin', tcp     => 3690 ),
  proftpd => n( tcp   => 21 ),
  nmbd    => n( group => 'samba', rcdname => 'samba', rcconfname => 'samba', udp => [ 137, 138 ], force_restart => 1, ),
  smbd    => n( group => 'samba', rcdname => 'samba', rcconfname => 'samba', tcp => [ 139, 445 ], force_restart => 1, ),
  winbindd     => n( group      => 'samba',        rcdname => 'samba', force_restart => 1, ),
  iscsi_target => n( process    => 'iscsi-target', tcp     => 3260,    udp           => 3260 ),
  nfsd         => n( rcconfname => 'nfs_server',   tcp     => 2049 ),
  healthd      => n,
  watchquagga  => n
  , # for zebra, bgpd and others use in rc.conf: watchquagga_flags=" --daemon --unresponsive-restart --restart-all '/usr/local/etc/rc.d/quagga restart' zebra bgpd"
  clamd      => n( rcdname => 'clamav-clamd',     rcconfname => 'clamav_clamd' ),
  freshclam  => n( rcdname => 'clamav-freshclam', rcconfname => 'clamav_freshclam' ),
  nut        => n( process => 'upsd' ),
  nut_upslog => n( process => 'upslog' ),
  nut_upsmon => n( process => 'upsmon' ),
  healthd    => n,
  icecast    => n( rcdname => 'icecast2',         http       => 8000 ),
  ipa        => n,
  tinyproxy  => n,         #tcp => 8888
  uhub       => n,
  verlihub   => n,
  hcsecd             => n( group => 'bluetooth', ),
  sdpd               => n( group => 'bluetooth', ),
  bthidd             => n( group => 'bluetooth', ),
  rfcomm_pppd_server => n( group => 'bluetooth', process => 'rfcomm_pppd', ),
  wpa_supplicant => n(    #start_params=>'em0'
    defaults => sub {
      for my $ifconfig ( grep { /^ifconfig/i } keys %svc ) {
        my $aliased = $ifconfig =~ /_(\w+\d+)$/ ? $1 : undef;
        for ( grep { /^\w+\d+$/ and $svc{$ifconfig}{$_} =~ /\bWPA\b/i } $aliased, keys %{ $svc{$ifconfig} } ) {
          my $if = $aliased || $_;
#printlog('info', "only one interface for wpa_supplicant supports, using [$svc{wpa_supplicant}{start_params}]") if $svc{wpa_supplicant}{start_params};
          $svc{wpa_supplicant}{start_params} ||= $if;
          $svc{wpa_supplicant}{enable} ||= 'YES';
          printlog( 'dbg', "wpa_supplicant enabled for interface $if" );
        }
      }
    }
  ),
  avahi_daemon   => n( process => 'avahi-daemon',   rcdname => 'avahi-daemon' ),     # udp=>5353
  avahi_dnsconfd => n( process => 'avahi-dnsconfd', rcdname => 'avahi-dnsconfd' ),
  openttd        => n( tcp     => 3979, group => 'games' ),
  freenet6       => n( process => 'gw6c' ),
  rtadvd         => n,
  rtsold         => n,
  route6d        => n,
  routed         => n,
  totd           => n,
  munin_node => n( process => 'munin-node', rcdname => 'munin-node', tcp => 4949 ),
  minidlna       => n( process => 'minidlnad'),
  miniupnpd      => n,
  miniupnpc      => n,
  minissdpd      => n,
  hald           => n,
  minetest       => n( process => 'minetestserver', udp => 30000, group => 'games', ),
  freeminer      => n( process => 'freeminerserver', udp => 30000, group => 'games', ),
);
if ( $config{config} ) {
  ( do $config{config} and !$@ and ++$config{config_run} )
    or printlog( 'err', "using default config because $!, $@ in [$config{config}]" );
} else {
  printlog( 'info', "using default config because watchmen.conf not exist" );
}

sub param_to_config ($) {
  my ($param) = @_;
  for my $w ( keys %$param ) {
    my $v = $param->{$w};
    next unless $w =~ s/^-//;
    my $where = ( $w =~ s/^-// ? '$config' : '$svc' );
    $v = 1 unless defined $v;
    local @_ = split( /__/, $w ) or next;
    eval( $where . join( '', map { '{$_[' . $_ . ']}' } ( 0 .. $#_ ) ) . ' = $v;' );
  }
}
sub config ($;$) { return $_[1] ? $svc{ $_[0] }{ $_[1] } || $config{ $_[1] } : $config{ $_[0] } }

sub array (@) {
  local @_ = map { ref $_ eq 'ARRAY' ? @$_ : $_ } ( @_ == 1 and !defined $_[0] ) ? () : @_;
  wantarray ? @_ : \@_;
}

sub array_any (@) {
  local @_ = map { ref $_ eq 'ARRAY' ? @$_ : ref $_ eq 'HASH' ? sort keys %$_ : ref $_ eq 'CODE' ? $_->() : $_ } @_;
  wantarray ? @_ : \@_;
}

sub in ($@) {
  my $v = shift;
  grep { $v eq $_ } &array_any;
}

sub ordered(@_) {
  sort { $svc{$b}{order} <=> $svc{$a}{order} || $a cmp $b } @_;
}

sub services() {
  ordered grep {
    $svc{$_}{enable}
      #and $svc{$_}{rcd} and -x $svc{$_}{rcd}
  } keys %svc;
}

sub watchable (@) {
  grep { $svc{$_}{process} or $svc{$_}{tcp} or $svc{$_}{udp} or $svc{$_}{http} or $svc{$_}{https} } @_;
}

sub group ($) {
  grep { in $_[0], $svc{$_}{group} } watchable services;
}
sub group_or_name ($)             { defined $_[0] && group( $_[0] )         ? group( $_[0] )         : $_[0] }
sub group_or_name_or_services ($) { defined $_[0] && group_or_name( $_[0] ) ? group_or_name( $_[0] ) : watchable services }

sub pushex (\$@) {
  local $_ = shift;
  $$_ = $$_ ? [ ref $$_ eq 'ARRAY' ? @$$_ : $$_, @_ ] : @_ > 1 ? \@_ : $_[0];
}

sub use_try ($;@) {
  ( my $path = ( my $module = shift ) . '.pm' ) =~ s{::}{/}g;
  $INC{$path} or eval 'use ' . $module . ' qw(' . ( join ' ', @_ ) . ');1;' and $INC{$path};
}
param_to_config scalar get_params;
{
  my ( $current, $order );

  sub prog(;$$) {
    my ( $name, $setorder ) = @_;
    return $prog{$current} unless $name;
    $prog{ $current = $name }{'order'} ||= ( $setorder or $order += ( $config{'order_step'} || 10 ) );
    return $prog{$current};
  }
}

sub process_check ($) {
  my ($s) = @_;
  return unless $svc{$s}{process};
  grep { $svc{$s}{process} eq $ps{$_}{process} } keys %ps;
}
prog('loadrc')->{force} = 1;
prog()->{func} = sub {
  my %byname;
  for ( values %svc ) {
    pushex $byname{ $_->{rcconfname} }, $_ if $_->{rcconfname};
  }
  for my $rcconf ( array $config{rcconf} ) {
    next unless open my $rcconfh, '<', $rcconf;
    while (<$rcconfh>) {
      if ( my ( $svc, $key, $value ) = /^\s*(\w+)_(\S+)\s*=\s*"([^"]+)"/i ) {    #"mcedit
        $value = 0 if $value =~ /^no(?:ne)?$/i;
        printlog( 'dbg', "rc.conf $key [$svc]=[$value]" );  # if $value eq 'enable';
                                                            #if ( local @_ = grep { $svc{$_}{rcconfname} eq $svc } keys %svc ) {
             #  printlog( 'rc','1', $svc, $key, $_, $value ), $svc{$_}{$key} = $value for @_;
        if ( local @_ = array $byname{$svc} ) {
          printlog( 'rc', '1', $svc, $key, $_, $value ), $_->{$key} = $value for @_;
        } else {
          $svc{$svc}{rcsource} = $rcconf unless $svc{$svc};
          printlog( 'rc', '2', $svc, $key, $value ), $svc{$svc}{$key} = $value;    #, next if exists $svc{$svc};
        }
      }
    }
    close $rcconfh;
  }
};
prog('service')->{force} = 0;
prog()->{func} = sub {
  my $order = 200000;
  if ( $config{service} ) {
    for (`$config{service} -e 2>/dev/null`) {
      chomp;
      my ( $rcd, $name ) = m{^((?:.+/)?([^/]++))$};
      $_->{order} = $order -= 10, $_->{enable} = 1, $_->{rcd} = $rcd,
        ( 1 || !watchable( $_->{name} ) ? () : printlog( 'service', $_->{name}, $_->{order}, $_->{rcd}, ) ),
        for grep { $_ } $svc{$name};    # array $rcd{$_};
    }
  }
};
prog('config')->{force} = 1;
prog()->{func} = sub {
  do $config{config} and ++$config{config_run} if $config{config};
};
prog('defaults')->{force} = 1;
prog()->{func} = sub {
  for my $s ( keys %svc ) {
    $svc{$s}{$_} ||= $config{default}{$_} for keys %{ $config{default} };
    $svc{$s}{defaults}->() if ref $svc{$s}{defaults} eq 'CODE';
    next unless $svc{$s}{enable};
    $svc{$s}{process} ||= $s unless $svc{$s}{rcsource};
    #($svc{$s}{rcdname} ||= $s) =~ tr/-/_/;
    $svc{$s}{rcdname} ||= $s;
    unless ( $svc{$s}{rcd} ) {
      for my $rcd ( array_any config $s, 'rcd' ) {
        last if $svc{$s}{rcd};
        for my $rcdext ( array config $s, 'rcdext' ) {
          if ( -x $rcd . $svc{$s}{rcdname} . $rcdext ) {
            $svc{$s}{rcd} ||= $rcd . $svc{$s}{rcdname} . $rcdext;
            if ( ref $config{rcd} eq 'HASH' ) { pushex $svc{$s}{$_}, $config{rcd}{$rcd}{$_} for keys %{ $config{rcd}{$rcd} }; }
            last;
          }
        }
      }
      printlog( 'info', "$s: rc.d script not exists [$svc{$s}{rcd}] [$svc{$s}{rcdname}]" ), $svc{$s}{enable} = 0
        #if !$svc{$s}{rcd} and !$svc{$s}{killer};
        if !$svc{$s}{rcd} and !( $svc{$s}{start} or $svc{$s}{stop} or $svc{$s}{restart} );
      #printlog('rcd', "$s detected [$svc{$s}{rcd}]");
    }
    $svc{$s}{controller} ||= "service $s", if $config{use_service};
    $svc{$s}{controller} ||= $svc{$s}{rcd};
    $svc{$s}{start} ||= $svc{$s}{controller} . ' ' . ( $svc{$s}{force_restart} ? 're' : '' ) . 'start ' . join ' ',
      @{ !$svc{$s}{start_params} ? [] : ref $svc{$s}{start_params} ? $svc{$s}{start_params} : [ $svc{$s}{start_params} ] }
      if $config{use_service}
        or $svc{$s}{rcd};
    $svc{$s}{stop} ||= $svc{$s}{controller} . ' stop' if $config{use_service} or $svc{$s}{rcd};
    $svc{$s}{restart} ||= $svc{$s}{controller} . ' restart'
      if !length $svc{$s}{restart} and ( $config{use_service} or $svc{$s}{rcd} );
    #$svc{$s}{restart} ||= "$svc{$s}{stop} ;; sleep $svc{$s}{sleep} ;; $svc{$s}{start}";
    $svc{$s}{restart} ||= sub {
      my $s = shift;
      action $s, 'stop';
      sleep $svc{$s}{sleep};
      action $s, 'start';
    };
    $svc{$s}{sleep} ||= 1 unless defined $svc{$s}{sleep};
    $svc{$s}{rcconf} ||= $s;
    $svc{$s}{name}   ||= $s;
#my $pid ;    $pid=     file_read($svc{$s}{pidfile}) if $svc{$s}{pidfile};$pid =~ s/\D//g;$svc{$s}{pid} ||= $pid ;printlog 'dev', 'pid', $s, $svc{$s}{pidfile},$svc{$s}{pid};
  }
};
our %rcorder;
prog('rcorder')->{force} = 1;
prog()->{func} = sub {
  my %rcd;
  pushex $rcd{ $svc{$_}{rcd} }, $svc{$_} for sort keys %svc;
  my $order = 200000;
  if ( $config{rcorder} ) {
    #for ( array_any $config{rcd} ) {
    my $rcdirs = join ' ', map { "$_*" } array_any $config{rcd};
    for (`$config{rcorder} $rcdirs 2>/dev/null`) {
      chomp;
      $order -= 10;
      $rcorder{$_} = $order;
      $_->{order} = $order, ( !watchable( $_->{name} ) ? () : printlog( 'rcorder', $_->{name}, $_->{order} ) ),
        for array $rcd{$_};
    }
    #    }
  }
};
prog('ps')->{force} = 1;
prog()->{func} = sub {
  %ps = ();
  my @ps = `$config{ps}`;
  printlog 'ps', "\n", @ps;
  local $_ = shift @ps;
  s/^\s+//;
  chomp;
  my @format = split /\s+/;
  my %format;
  my $i = 0;
  $format{$_} = $i++ for @format;
  #printlog 'fmt', @format;
  my $psline = 0;
  for (@ps) {
    s/^\s+//;
    chomp;
    local @_ = split /\s+/, $_, @format;
    printlog( 'bad pid', join ':', @_ ), next unless $_[ $format{PID} ] =~ /^\d+$/;    #== farcolorer
    my $ps = $ps{ $_[ $format{PID} ] } ||= {};
    @{$ps}{@format} = @_;
    $ps->{psline} = $psline++;
    if ( $ps->{TIME} =~ /(\d+):(\d+)(\.\d+)?/ ) {
      $ps->{time} = $1 * 60 + $2 + "0$3";
      #printlog('dev', 'time', $ps->{TIME}, $ps->{time});
    }
    my $starter = q{(?:-?\S*perl|(?:ba)?sh)};
    #/usr/bin/perl -wT /usr/local/sbin/munin-node (perl5.16.2)
    #/usr/local/bin/perl -wT /usr/local/sbin/munin-node
    $ps->{process} ||= $1, next if $ps->{COMMAND} =~ m{^$starter(?: -\S+)* \S*/([^/]+)(?: \(\S+\))?$};
    #/usr/local/sbin/munin-node (perl5.14.2)
    $ps->{process} ||= $1, next if $ps->{COMMAND} =~ m{^\S*/([^/]+) \(\S+\)$};
    #proftpd: (accepting connections) (proftpd)
    $ps->{process} ||= $1, next if $ps->{COMMAND} =~ m{.*\((.+?)\)$};
    #./minetestserver
    $ps->{process} ||= $1, next if $ps->{COMMAND} =~ m{^$starter?(?:\S*?/)?([^\s/\\\[\]]+)$};
    #sh -c myisamchk -v --recover --force /var/db/mysql/t/*.MYI 2>&1
    $ps->{process} ||= $1, next if $ps->{COMMAND} =~ m{^\S*/(\S+)};
    #[mysqld]
    $ps->{process} ||= $1, next if $ps->{COMMAND} =~ m{^\[([^\]]+)\]$};
  }
  #printlog 'newps', Dumper \%ps;
  #printlog 'com-prc', $_->{process}, ":\t", $_->{COMMAND} for values %ps;
};
prog('check')->{func} = sub {
  my ($check) = @_;
  for my $s ( group_or_name_or_services $check ) {
    $logto = $s;
    printlog( 'check', "looking at [$s] [$svc{$s}{rcd}] [$svc{$s}{process}]" );
    next if !$svc{$s}{process};
    my $founded;
    for my $p ( process_check $s) {
      #printlog('dev', $s, $p);
      for my $max ( grep { $svc{$s}{max}{$_} } keys %{ $svc{$s}{max} || {} } ) {
        #printlog('dev', "look at $s limit [$max] pid=$p", $svc{$s}{max}{$max} , $ps{$p}{$max});
        printlog( 'warn', "$s limit [$max]", $ps{$p}{$max}, '>', $svc{$s}{max}{$max} ), $svc{$s}{action} ||= 'restart',
          ++$svc{$s}{action_pid}{$p},
          if $ps{$p}{$max} > $svc{$s}{max}{$max};
      }
      ++$founded;
    }
    printlog( 'ps', "[$s] processes [$founded]" );
    if ( !$founded ) {
      $svc{$s}{action} ||= 'start';
      printlog( 'warn', "$s no_proc!", $svc{$s}{process} ) if $svc{$s}{ $svc{$s}{action} };    #start
    } elsif ( $svc{$s}{min_proc} and $founded < $svc{$s}{min_proc} ) {
      printlog( 'warn', "$s min_proc[$founded/$svc{$s}{min_proc}]!" );                         #restart
      $svc{$s}{action} ||= 'restart';
    } elsif ( $svc{$s}{max_proc} and $founded > $svc{$s}{max_proc} ) {
      printlog( 'warn', "$s max_proc[$founded/$svc{$s}{max_proc}]!" );                         #restart
      $svc{$s}{action} ||= 'restart';
    }
  }
  for my $s ( group_or_name_or_services $check ) {
    for my $prot (qw(tcp udp)) {
      $svc{$s}{$prot} ||= $svc{$s}{http} if $prot eq 'tcp';
      next unless $svc{$s}{$prot};
      last if $svc{$s}{action};
    PORT: for my $port ( array $svc{$s}{$prot} ) {
        my $tries = $svc{$s}{port_tries} || 1;
        for my $try ( 1 .. $tries ) {
          my $log = "$s $prot $svc{$s}{host}:$port timeout=$svc{$s}{timeout} try=$try/$tries";
          printlog( 'port', "connecting to service $log" );
          my $time   = time;
          my $socket = IO::Socket::INET->new(
            'PeerAddr' => $svc{$s}{host},
            'PeerPort' => $port,
            'Proto'    => $prot,
            'Timeout'  => $svc{$s}{timeout},
          );
          $time = human( 'time_period', time - $time );
          printlog( 'port', "connected per", $time ), next PORT if $socket;
          printlog( 'warn', "no answer", $log, $time, $socket, );
        }
        $svc{$s}{action} ||= 'restart';
        last PORT;
      }
    }
    for my $prot (qw(http https)) {
      next unless $svc{$s}{$prot};
      last if $svc{$s}{action};
    PORTOK: for my $port ( array $svc{$s}{$prot} ) {
        $port = 80  if $port == 1 and $prot eq 'http';
        $port = 443 if $port == 1 and $prot eq 'https';
        printlog( 'port', "connecting to service $s $prot $svc{$s}{host}:$port" );
        my $time = time;
        next unless use_try 'LWP::UserAgent' and use_try 'URI::URL';
        my $ua = LWP::UserAgent->new( 'timeout' => config( $s, 'timeout' ), %{ config( $s, 'lwp' ) || {} }, );
        my $get =
            'http://'
          . ( config( $s, 'http_host' ) || config( $s, 'host' ) || 'localhost' ) . ':'
          . $port
          . config( $s, 'http_path' );
        my $resp = $ua->request(
          HTTP::Request->new(
            config( $s, 'http_method' ) || 'GET',
            URI::URL->new($get),
            HTTP::Headers->new( 'User-Agent' => config( $s, 'http_useragent' ), %{ config( $s, 'http_headers' ) || {} } ),
            config( $s, 'http_content' )
          )
        );
        my $result = $resp->is_success ? $resp->as_string : undef;
        printlog( 'http', 'recv', $get, 'per', human( 'time_period', time() - $time ), length $result, 'bytes', ':', $result );
        my $code = config( $s, 'http_code' );

        if ($code) {
          local $_ = $resp->code();
          printlog( 'http', "code recv [$_](", $resp->message(), "), want [$code]", ref $code );
          my $code_ok;
          if   ( ref $code eq 'Regexp' ) { ++$code_ok if $_ =~ $code; }
          else                           { ++$code_ok if $_ =~ /$code/; }
          unless ($code_ok) {
            printlog( 'warn', 'no good http code', $get, ":", $resp->message(), 'recv', $_, ', want ', $code, "[$code_ok]" );
            $svc{$s}{action} ||= 'restart';
            last;
          }
        }
        $time = human( 'time_period', time() - $time );
        my $check = $svc{$s}{ $prot . '_check' };
        if ( ref $check eq 'CODE' ) { next if $check->($result) }
        elsif ($check) {
          for my $check ( array $check) {
            $check = qr/\Q$check/ if ref $check ne 'Regexp';
            printlog( 'http', 'check match', $check ), next PORTOK if $result =~ $check;
          }
          printlog( 'restart', 'no', $check, ' in ', $result );
        } else {
          next;
        }
        $svc{$s}{action} ||= 'restart';
        last;
      }
    }
    if ( $svc{$s}{action} ) {
      ++$stat{chain}{$s}{ $svc{$s}{action} };
#printlog 'chain', $stat{chain}{$s}{$svc{$s}{action}} , $svc{$s}{chain_noaction} , !($stat{chain}{$s}{$svc{$s}{action}} % $svc{$s}{chain_try_every});
    } else {
      delete $stat{chain}{$s}{ $svc{$s}{action} } if exists $stat{chain}{$s};
    }
    next
      if exists $stat{chain}{$s}
        and $stat{chain}{$s}{ $svc{$s}{action} } > $svc{$s}{chain_noaction}
        and $svc{$s}{chain_try_every}
        and $stat{chain}{$s}{ $svc{$s}{action} } % $svc{$s}{chain_try_every};
    if ( $svc{$s}{dbi} ) {
      unless (
        alarmed(
          $svc{$s}{dbi_timeout} || 5,
          sub {
            $svc{$s}{action} ||= dbi_check( $svc{$s} );
            1;
          }
        )
        )
      {
        printlog( 'err', 'dbi', "timeout" );
        $svc{$s}{action} ||= 'restart';
      }
    }
    if ( !$svc{$s}{action} and ref $svc{$s}{check} eq 'CODE' ) {
      $svc{$s}{action} ||= eval { $svc{$s}{check}->( $svc{$s} ) };
      printlog( 'custom', 'fail', $@ ), $svc{$s}{action} = 'restart' if $@;
    }
    action $s, $svc{$s}{action};
    delete $svc{$s}{action};
  }
  $logto = undef;
};

sub dbi_check ($) {
  my ($ss) = @_;
  if ( use_try('DBI') ) {
    my $params = $_[0]->{params} || $config{dbi_params}{ $_[0]->{dbi} };
    local %_ = (
      params => $params,
      ( map { $_ => $_[0]->{$_} } grep { defined $_[0]->{$_} } qw(user pass dbi), @$params ),
      ( map { $_ => $_[0]->{tcp} } grep { defined $_[0]->{tcp} } qw(port) ),
    );
    local @_ = (
      "dbi:$_{'dbi'}:" . join( ';', map { $_ . '=' . $_{$_} } grep { defined $_{$_} } @{ $_{'params'} } ),
      $_{'user'}, $_{'pass'}, $_{'connect_params'}
    );
    printlog( 'dbi', @_ );
    $ss->{dbh} ||= DBI->connect(@_);
    printlog( 'err', 'no dbh', $DBI::err, $DBI::errstr ), return 'restart' if !$ss->{dbh} or $DBI::err or $DBI::errstr;
    unless ( $ss->{db_query} ) {
      $ss->{db_query}  = '1+1';
      $ss->{db_answer} = 2;
    }
    my $qn      = -1;
    my @answers = array $ss->{db_answer};
  QUERY: for my $query ( map { 'SELECT ' . $_ } array $ss->{db_query} ) {
      ++$qn;
      my $time = time;
      my $sth  = $ss->{dbh}->prepare($query);
      printlog( 'err', 'no sth', $DBI::err, $DBI::errstr ), return 'restart' if !$sth;
      printlog( 'err', "executing [$query] = [$_] fail [$DBI::err, $DBI::errstr]" ), return 'restart'
        unless local $_ = $sth->execute;
      $time = time - $time;
      printlog( 'err', "long db answer per [$time>$ss->{db_query_time_max}]" ), return 'restart'
        if $ss->{db_query_time_max} and $time > $ss->{db_query_time_max};
      my $rows = 0;

      while ( my $ref = $sth->fetchrow_hashref() ) {
        ++$rows;
        printlog 'dbi', "db answer per [", human( 'time_period', $time ), "]", Dumper $ref;
        for ( values %$ref ) {
          next QUERY if $ss->{db_answer_true} and $_;
          next QUERY if defined $answers[$qn] and $_ eq $answers[$qn];
        }
        printlog( 'warn', 'strange answer', Dumper $ref);
      }
      printlog( 'err', " $rows < $ss->{db_query_min} selected [$query]" ), return 'restart'
        if defined $ss->{db_query_min} and $rows < $ss->{db_query_min};
    }
  }
}
prog('start')->{func} = sub {
  unlink for <$config{lock_dir}/*.lock>;
};
prog('stop')->{func} = sub {
  #local $config{log_all} = 1;
  local @_ = group_or_name_or_services $_[0];
  @_ = reverse ordered @_;
  printlog 'stop', ':', $@, action $_, 'stop_hard' for @_;
};
prog('restart')->{func} = sub {
  prog_run 'stop',  @_;
  prog_run 'check', @_;
};
prog('list')->{func} = sub {
  local $config{log_all} = 1;
  printlog 'list', ':', watchable services;
};
prog('avail')->{func} = sub {
  local $config{log_all} = 1;
  printlog 'avail', ':', watchable ordered keys %svc;
};
prog('service-e')->{func} = sub {    #wrong
  print $svc{$_}{rcd}, "\n"
    for grep { $svc{$_}{rcd} }
    map { s{.+/}{}g; $_ }
    sort { $rcorder{$b} <=> $rcorder{$a} } keys %rcorder;
};
prog('group')->{func} = sub {
  local $config{log_all} = 1;
  local %_;
  for my $s ( watchable services ) {
    pushex $_{$_}, $s for grep { $_ } array $svc{$s}{group};
  }
  printlog 'group', Dumper \%_;
};
prog('dump')->{func} = sub {
  local $config{log_all} = 1;
  printlog 'dmp', $root_path, Dumper \( %config, %svc, %prog, %ps, %stat );
};
prog('help')->{func} = sub {
  local $config{log_all} = 1;
  print "\n Avail commands:\n";
  for my $prog ( sort { $prog{$a}{order} <=> $prog{$b}{order} } keys %prog ) {
    print "$prog ";
  }
  print "\n";
};
sub print_stat () { printlog 'stat', Dumper \%stat if %stat; }

sub mail () {
  my %mailto;
  for my $s ( keys %logs ) {
    next unless $stat{action}{$s};
    $mailto{$_}{$s} = $logs{$s} for grep { $_ } array $svc{$s}{mail};
  }
  %logs = ();
  for my $mail ( sort keys %mailto ) {
    last unless use_try 'MIME::Lite';
    eval {
      printlog(
        'info',
        'mail to',
        $mail,
        alarmed(
          $config{mail_timeout} || 10,
          sub {
            my $mailer = MIME::Lite->new(
              To      => "$mail",
              From    => $config{mail_from},
              Subject => ( $config{mail_subject} || 'watchmen action' ),
              Data    => (
                join "\n\n",
                map {
                  "Service: $_:\n" . join "\n",
                    map { join ' ', @$_ }
                    @{ $mailto{$mail}{$_} }
                  } sort keys %{ $mailto{$mail} }
                )
                . "\n\n"
                . Dumper \%stat,
              %{ $config{mail} || {} },
            );
            $mailer->send( @{ $config{mail_send} }, );
          }
        )
      );
    };
  }
  #printlog 'dev', Dumper \%mailto;
}
prog('keep')->{func} = sub {
  prog('check')->{force} = 1;
  my $stop = 0;
  $SIG{KILL} = $SIG{TERM} = $SIG{INT} = $SIG{QUIT} = sub { ++$stop };
  $SIG{INFO} = \&print_stat;
  printlog 'keep', "checking every $config{sleep} seconds", @_;
  while ( !$stop ) {
    #progs(@_);
    prog_run 'ps',    @_;
    prog_run 'check', @_;
    mail;
    sleep $config{sleep};
  }
  print_stat;
};

sub progs() {
  for my $prog ( sort { $prog{$a}{order} <=> $prog{$b}{order} } keys %prog ) {
    next unless $prog{$prog}{force};
    prog_run $prog, @_;
  }
}
unless (caller) {
  my $time = time;
  my @wantrun;
  for (@ARGV) {
    next if /^-/;
    push @wantrun, [ get_params_one $_ ];
  }
  prog('check')->{force} = 1 unless @wantrun;
  progs;
  prog_run $_->[0], $_->[1] for @wantrun;
  printlog 'info', 'finished per', human( 'time_period', time - $time ), times;
  mail;
  #printlog 'dev', Dumper \%ENV;
  #printlog 'dev', Dumper \%logs;
}
1;
